{-# LANGUAGE ApplicativeDo   #-}
{-# LANGUAGE NamedFieldPuns  #-}
{-# LANGUAGE RecordWildCards #-}

module Command.Proc
       ( createCommandProcs
       ) where

import           Universum

import           Data.Constraint (Dict (..))
import           Data.Default (def)
import           Data.List ((!!))
import qualified Data.Map as Map
import           Formatting (build, int, sformat, stext, (%))
import qualified Text.JSON.Canonical as CanonicalJSON

import           Pos.Chain.Delegation (HeavyDlgIndex (..))
import           Pos.Chain.Genesis as Genesis (Config (..), configEpochSlots,
                     configGeneratedSecretsThrow)
import           Pos.Chain.Genesis (gsSecretKeys)
import           Pos.Chain.Txp (TxOut (..), TxpConfiguration)
import           Pos.Chain.Update (BlockVersionModifier (..),
                     SoftwareVersion (..))
import           Pos.Client.KeyStorage (addSecretKey, getSecretKeysPlain)
import           Pos.Client.Txp.Balances (getBalance)
import           Pos.Core (AddrStakeDistribution (..), StakeholderId,
                     addressHash, mkMultiKeyDistr, unsafeGetCoin)
import           Pos.Core.Common (AddrAttributes (..), AddrSpendingData (..),
                     makeAddress)
import           Pos.Core.NetworkMagic (makeNetworkMagic)
import           Pos.Crypto (PublicKey, emptyPassphrase, encToPublic,
                     fullPublicKeyF, hashHexF, noPassEncrypt, safeCreatePsk,
                     unsafeCheatingHashCoerce, withSafeSigner)
import           Pos.DB.Class (MonadGState (..))
import           Pos.Infra.Diffusion.Types (Diffusion (..))
import           Pos.Util.Trace (fromTypeclassWlog)
import           Pos.Util.UserSecret (WalletUserSecret (..), readUserSecret,
                     usKeys, usPrimKey, usWallet, userSecret)
import           Pos.Util.Util (eitherToThrow)
import           Pos.Util.Wlog (CanLog, HasLoggerName, logError, logInfo,
                     logWarning)

import           Command.BlockGen (generateBlocks)
import           Command.Help (mkHelpMessage)
import qualified Command.Rollback as Rollback
import qualified Command.Tx as Tx
import           Command.TyProjection (tyAddrDistrPart, tyAddrStakeDistr,
                     tyAddress, tyApplicationName, tyBlockVersion,
                     tyBlockVersionModifier, tyBool, tyByte, tyCoin,
                     tyCoinPortion, tyEither, tyEpochIndex, tyFilePath, tyHash,
                     tyInt, tyProposeUpdateSystem, tyPublicKey,
                     tyScriptVersion, tySecond, tySoftwareVersion,
                     tyStakeholderId, tySystemTag, tyTxOut, tyValue, tyWord,
                     tyWord32)
import qualified Command.Update as Update
import           Lang.Argument (getArg, getArgMany, getArgOpt, getArgSome,
                     typeDirectedKwAnn)
import           Lang.Command (CommandProc (..), UnavailableCommand (..))
import           Lang.Name (Name)
import           Lang.Value (AddKeyParams (..), AddrDistrPart (..),
                     GenBlocksParams (..), ProposeUpdateParams (..),
                     ProposeUpdateSystem (..), RollbackParams (..), Value (..))
import           Mode (MonadAuxxMode, deriveHDAddressAuxx,
                     makePubKeyAddressAuxx)
import           Repl (PrintAction)

createCommandProcs ::
       forall m. (MonadIO m, CanLog m, HasLoggerName m)
    => Maybe Genesis.Config
    -> Maybe TxpConfiguration
    -> Maybe (Dict (MonadAuxxMode m))
    -> PrintAction m
    -> Maybe (Diffusion m)
    -> [CommandProc m]
createCommandProcs mCoreConfig mTxpConfig hasAuxxMode printAction mDiffusion = rights . fix $ \commands -> [

    return CommandProc
    { cpName = "L"
    , cpArgumentPrepare = identity
    , cpArgumentConsumer = getArgMany tyValue "elem"
    , cpExec = return . ValueList
    , cpHelp = "construct a list"
    },

    let name = "pk" in
    needsAuxxMode name >>= \Dict ->
    return CommandProc
    { cpName = name
    , cpArgumentPrepare = identity
    , cpArgumentConsumer = getArg tyInt "i"
    , cpExec = fmap ValuePublicKey . toLeft . Right
    , cpHelp = "public key for secret #i"
    },

    let name = "s" in
    needsAuxxMode name >>= \Dict ->
    return CommandProc
    { cpName = name
    , cpArgumentPrepare = identity
    , cpArgumentConsumer = getArg (tyPublicKey `tyEither` tyInt) "pk"
    , cpExec = fmap ValueStakeholderId . toLeft . Right
    , cpHelp = "stakeholder id (hash) of the specified public key"
    },

    let name = "addr" in
    needsCoreConfig name >>= \genesisConfig ->
    needsAuxxMode name >>= \Dict ->
    let nm = makeNetworkMagic (configProtocolMagic genesisConfig) in
    return CommandProc
    { cpName = name
    , cpArgumentPrepare = map
        $ typeDirectedKwAnn "distr" tyAddrStakeDistr
    , cpArgumentConsumer =
        (,) <$> getArg (tyPublicKey `tyEither` tyInt) "pk"
            <*> getArgOpt tyAddrStakeDistr "distr"
    , cpExec = \(pk', mDistr) -> do
        pk <- toLeft pk'
        addr <- case mDistr of
            Nothing -> makePubKeyAddressAuxx nm (configEpochSlots genesisConfig) pk
            Just distr -> return $
                makeAddress (PubKeyASD pk) (AddrAttributes Nothing distr nm)
        return $ ValueAddress addr
    , cpHelp = "address for the specified public key. a stake distribution \
             \ can be specified manually (by default it uses the current epoch \
             \ to determine whether we want to use bootstrap distr)"
    },

    let name = "addr-hd" in
    needsCoreConfig name >>= \genesisConfig ->
    needsAuxxMode name >>= \Dict ->
    return CommandProc
    { cpName = name
    , cpArgumentPrepare = identity
    , cpArgumentConsumer = getArg tyInt "i"
    , cpExec = \i -> do
        sks <- getSecretKeysPlain
        sk <- evaluateWHNF (sks !! i) -- WHNF is sufficient to force possible errors
                                      -- from using (!!). I'd use NF but there's no
                                      -- NFData instance for secret keys.
        let nm = makeNetworkMagic (configProtocolMagic genesisConfig)
        addrHD <- deriveHDAddressAuxx nm (configEpochSlots genesisConfig) sk
        return $ ValueAddress addrHD
    , cpHelp = "address of the HD wallet for the specified public key"
    },

    return CommandProc
    { cpName = "tx-out"
    , cpArgumentPrepare = map
        $ typeDirectedKwAnn "addr" tyAddress
    , cpArgumentConsumer = do
        txOutAddress <- getArg tyAddress "addr"
        txOutValue <- getArg tyCoin "value"
        return TxOut{..}
    , cpExec = return . ValueTxOut
    , cpHelp = "construct a transaction output"
    },

    let name = "dp" in
    needsAuxxMode name >>= \Dict ->
    return CommandProc
    { cpName = name
    , cpArgumentPrepare = identity
    , cpArgumentConsumer = do
        adpStakeholderId <- getArg (tyStakeholderId `tyEither` tyPublicKey `tyEither` tyInt) "s"
        adpCoinPortion <- getArg tyCoinPortion "p"
        return (adpStakeholderId, adpCoinPortion)
    , cpExec = \(sId', cp) -> do
        sId <- toLeft sId'
        return $ ValueAddrDistrPart (AddrDistrPart sId cp)
    , cpHelp = "construct an address distribution part"
    },

    let name = "distr" in
    needsAuxxMode name >>= \Dict ->
    return CommandProc
    { cpName = name
    , cpArgumentPrepare = identity
    , cpArgumentConsumer = getArgSome tyAddrDistrPart "dp"
    , cpExec = \parts -> do
        distr <- case parts of
            AddrDistrPart sId coinPortion :| []
              | coinPortion == maxBound ->
                return $ SingleKeyDistr sId
            _ -> eitherToThrow $
                 mkMultiKeyDistr . Map.fromList $
                 map (\(AddrDistrPart s cp) -> (s, cp)) $
                 toList parts
        return $ ValueAddrStakeDistribution distr
    , cpHelp = "construct an address distribution (use 'dp' for each part)"
    },

    return . procConst "boot" $ ValueAddrStakeDistribution BootstrapEraDistr,

    return . procConst "true" $ ValueBool True,
    return . procConst "false" $ ValueBool False,

    let name = "balance" in
    needsCoreConfig name >>= \genesisConfig ->
    needsAuxxMode name >>= \Dict ->
    let nm = makeNetworkMagic (configProtocolMagic genesisConfig) in
    return CommandProc
    { cpName = name
    , cpArgumentPrepare = identity
    , cpArgumentConsumer = getArg (tyAddress `tyEither` tyPublicKey `tyEither` tyInt) "addr"
    , cpExec = \addr' -> do
        addr <-
          either return (makePubKeyAddressAuxx nm $ configEpochSlots genesisConfig) <=<
          traverse (either return getPublicKeyFromIndex) $ addr'
        balance <- getBalance (configGenesisData genesisConfig) addr
        return $ ValueNumber (fromIntegral . unsafeGetCoin $ balance)
    , cpHelp = "check the amount of coins on the specified address"
    },

    let name = "bvd" in
    needsAuxxMode name >>= \Dict ->
    return CommandProc
    { cpName = name
    , cpArgumentPrepare = identity
    , cpArgumentConsumer = do pure ()
    , cpExec = \() -> ValueBlockVersionData <$> gsAdoptedBVData
    , cpHelp = "return current (adopted) BlockVersionData"
    },

    let name = "send-to-all-genesis" in
    needsCoreConfig name >>= \genesisConfig ->
    needsDiffusion name >>= \diffusion ->
    needsAuxxMode name >>= \Dict ->
    return CommandProc
    { cpName = name
    , cpArgumentPrepare = identity
    , cpArgumentConsumer = do
        stagpGenesisTxsPerThread <- getArg tyInt "genesisTxsPerThread"
        stagpTxsPerThread <- getArg tyInt "txsPerThread"
        stagpConc <- getArg tyInt "conc"
        stagpDelay <- getArg tyInt "delay"
        stagpTpsSentFile <- getArg tyFilePath "file"
        return Tx.SendToAllGenesisParams{..}
    , cpExec = \stagp -> do
        secretKeys <- gsSecretKeys <$> configGeneratedSecretsThrow genesisConfig
        Tx.sendToAllGenesis genesisConfig secretKeys diffusion stagp
        return ValueUnit
    , cpHelp = "create and send transactions from all genesis addresses \
               \ for <duration> seconds, <delay> in ms. <conc> is the \
               \ number of threads that send transactions concurrently."
    },

    let name = "send-from-file" in
    needsDiffusion name >>= \diffusion ->
    needsAuxxMode name >>= \Dict ->
    return CommandProc
    { cpName = name
    , cpArgumentPrepare = identity
    , cpArgumentConsumer = getArg tyFilePath "file"
    , cpExec = \filePath -> do
        Tx.sendTxsFromFile diffusion filePath
        return ValueUnit
    , cpHelp = ""
    },

    let name = "send" in
    needsCoreConfig name >>= \genesisConfig ->
    needsDiffusion name >>= \diffusion ->
    needsAuxxMode name >>= \Dict ->
    return CommandProc
    { cpName = name
    , cpArgumentPrepare = identity
    , cpArgumentConsumer =
        (,) <$> getArg tyInt "i"
            <*> getArgSome tyTxOut "out"
    , cpExec = \(i, outputs) -> do
        Tx.send genesisConfig diffusion i outputs
        return ValueUnit
    , cpHelp = "send from #i to specified transaction outputs \
               \ (use 'tx-out' to build them)"
    },

    let name = "vote" in
    needsCoreConfig name >>= \genesisConfig ->
    needsDiffusion name >>= \diffusion ->
    needsAuxxMode name >>= \Dict ->
    return CommandProc
    { cpName = name
    , cpArgumentPrepare = identity
    , cpArgumentConsumer =
        (,,) <$> getArg tyInt "i"
             <*> getArg tyBool "agree"
             <*> getArg tyHash "up-id"
    , cpExec = \(i, decision, upId) -> do
        Update.vote (configProtocolMagic genesisConfig) diffusion i decision upId
        return ValueUnit
    , cpHelp = "send vote for update proposal <up-id> and \
               \ decision <agree> ('true' or 'false'), \
               \ using secret key #i"
    },

    return CommandProc
    { cpName = "bvm"
    , cpArgumentPrepare = identity
    , cpArgumentConsumer = do
        bvmScriptVersion <- getArgOpt tyScriptVersion "script-version"
        bvmSlotDuration <- getArgOpt tySecond "slot-duration"
        bvmMaxBlockSize <- getArgOpt tyByte "max-block-size"
        bvmMaxHeaderSize <- getArgOpt tyByte "max-header-size"
        bvmMaxTxSize <- getArgOpt tyByte "max-tx-size"
        bvmMaxProposalSize <- getArgOpt tyByte "max-proposal-size"
        bvmMpcThd <- getArgOpt tyCoinPortion "mpc-thd"
        bvmHeavyDelThd <- getArgOpt tyCoinPortion "heavy-del-thd"
        bvmUpdateVoteThd <- getArgOpt tyCoinPortion "update-vote-thd"
        bvmUpdateProposalThd <- getArgOpt tyCoinPortion "update-proposal-thd"
        let bvmUpdateImplicit = Nothing -- TODO
        let bvmSoftforkRule = Nothing -- TODO
        let bvmTxFeePolicy = Nothing -- TODO
        bvmUnlockStakeEpoch <- getArgOpt tyEpochIndex "unlock-stake-epoch"
        pure BlockVersionModifier{..}
    , cpExec = return . ValueBlockVersionModifier
    , cpHelp = "construct a BlockVersionModifier"
    },

    return CommandProc
    { cpName = "upd-bin"
    , cpArgumentPrepare = identity
    , cpArgumentConsumer = do
        pusSystemTag <- getArg tySystemTag "system"
        pusInstallerPath <- getArgOpt tyFilePath "installer-path"
        pusBinDiffPath <- getArgOpt tyFilePath "bin-diff-path"
        pure ProposeUpdateSystem{..}
    , cpExec = return . ValueProposeUpdateSystem
    , cpHelp = "construct a part of the update proposal for binary update"
    },

    let name = "software" in
    return CommandProc
    { cpName = name
    , cpArgumentPrepare = identity
    , cpArgumentConsumer = do
        appName <- getArg tyApplicationName "name"
        number <- getArg tyWord32 "n"
        pure (appName, number)
    , cpExec = \(svAppName, svNumber) -> do
        return $ ValueSoftwareVersion SoftwareVersion{..}
    , cpHelp = "Construct a software version from application name and number"
    },

    let name = "propose-update" in
    needsCoreConfig name >>= \genesisConfig ->
    needsDiffusion name >>= \diffusion ->
    needsAuxxMode name >>= \Dict ->
    return CommandProc
    { cpName = name
    , cpArgumentPrepare = map
        $ typeDirectedKwAnn "bvm" tyBlockVersionModifier
        . typeDirectedKwAnn "update" tyProposeUpdateSystem
        . typeDirectedKwAnn "block-version" tyBlockVersion
        . typeDirectedKwAnn "software-version" tySoftwareVersion
    , cpArgumentConsumer = do
        puSecretKeyIdx <- getArg tyInt "i"
        puVoteAll <- getArg tyBool "vote-all"
        puBlockVersion <- getArg tyBlockVersion "block-version"
        puSoftwareVersion <- getArg tySoftwareVersion "software-version"
        puBlockVersionModifier <- fromMaybe def <$> getArgOpt tyBlockVersionModifier "bvm"
        puUpdates <- getArgMany tyProposeUpdateSystem "update"
        pure ProposeUpdateParams{..}
    , cpExec = \params ->
        -- FIXME: confuses existential/universal. A better solution
        -- is to have two ValueHash constructors, one with universal and
        -- one with existential (relevant via singleton-style GADT) quantification.
        ValueHash . unsafeCheatingHashCoerce
            <$> Update.propose (configProtocolMagic genesisConfig) diffusion params
    , cpHelp = "propose an update with one positive vote for it \
               \ using secret key #i"
    },

    return CommandProc
    { cpName = "hash-installer"
    , cpArgumentPrepare = identity
    , cpArgumentConsumer = getArg tyFilePath "file"
    , cpExec = \filePath -> do
        Update.hashInstaller printAction filePath
        return ValueUnit
    , cpHelp = ""
    },

    let name = "delegate-heavy" in
    needsCoreConfig name >>= \genesisConfig ->
    needsDiffusion name >>= \diffusion ->
    needsAuxxMode name >>= \Dict ->
    return CommandProc
    { cpName = name
    , cpArgumentPrepare = identity
    , cpArgumentConsumer =
      (,,,) <$> getArg tyInt "i"
            <*> getArg tyPublicKey "pk"
            <*> getArg tyEpochIndex "cur"
            <*> getArg tyBool "dry"
    , cpExec = \(i, delegatePk, curEpoch, dry) -> do
        issuerSk <- (!! i) <$> getSecretKeysPlain
        withSafeSigner issuerSk (pure emptyPassphrase) $ \case
            Nothing -> logError "Invalid passphrase"
            Just ss -> do
                let psk = safeCreatePsk (configProtocolMagic genesisConfig)
                                        ss
                                        delegatePk
                                        (HeavyDlgIndex curEpoch)
                if dry
                then do
                    printAction $
                        sformat ("JSON: key "%hashHexF%", value "%stext)
                            (addressHash $ encToPublic issuerSk)
                            (decodeUtf8 $
                                CanonicalJSON.renderCanonicalJSON $
                                runIdentity $
                                CanonicalJSON.toJSON psk)
                else do
                    sendPskHeavy diffusion psk
                    logInfo "Sent heavyweight cert"
        return ValueUnit
    , cpHelp = ""
    },

    let name = "generate-blocks" in
    needsCoreConfig name >>= \genesisConfig ->
    needsAuxxMode name >>= \Dict ->
    needsTxpConfig name >>= \txpConfig ->
    return CommandProc
    { cpName = name
    , cpArgumentPrepare = identity
    , cpArgumentConsumer = do
        bgoBlockN <- getArg tyWord32 "n"
        bgoSeed <- getArgOpt tyInt "seed"
        return GenBlocksParams{..}
    , cpExec = \params -> do
        generateBlocks genesisConfig txpConfig params
        return ValueUnit
    , cpHelp = "generate <n> blocks"
    },

    let name = "add-key-pool" in
    needsCoreConfig name >>= \genesisConfig ->
    needsAuxxMode name >>= \Dict ->
    return CommandProc
    { cpName = name
    , cpArgumentPrepare = identity
    , cpArgumentConsumer = getArgMany tyInt "i"
    , cpExec = \is -> do
        when (null is) $ logWarning "Not adding keys from pool (list is empty)"
        secretKeys <- gsSecretKeys <$> configGeneratedSecretsThrow genesisConfig
        forM_ is $ \i -> do
            key <- evaluateNF $ secretKeys !! i
            addSecretKey $ noPassEncrypt key
        return ValueUnit
    , cpHelp = ""
    },

    let name = "add-key" in
    needsAuxxMode name >>= \Dict ->
    return CommandProc
    { cpName = name
    , cpArgumentPrepare = identity
    , cpArgumentConsumer = do
        akpFile <- getArg tyFilePath "file"
        akpPrimary <- getArg tyBool "primary"
        return AddKeyParams {..}
    , cpExec = \AddKeyParams {..} -> do
        secret <- readUserSecret fromTypeclassWlog akpFile
        if akpPrimary then do
            let primSk = fromMaybe (error "Primary key not found") (secret ^. usPrimKey)
            addSecretKey $ noPassEncrypt primSk
        else do
            let ks = secret ^. usKeys
            printAction $ sformat ("Adding "%build%" secret keys") (length ks)
            mapM_ addSecretKey ks
        return ValueUnit
    , cpHelp = ""
    },

    let name = "rollback" in
    needsCoreConfig name >>= \genesisConfig ->
    needsAuxxMode name >>= \Dict ->
    return CommandProc
    { cpName = name
    , cpArgumentPrepare = identity
    , cpArgumentConsumer = do
        rpNum <- getArg tyWord "n"
        rpDumpPath <- getArg tyFilePath "dump-file"
        pure RollbackParams{..}
    , cpExec = \RollbackParams{..} -> do
        Rollback.rollbackAndDump genesisConfig rpNum rpDumpPath
        return ValueUnit
    , cpHelp = ""
    },

    let name = "listaddr" in
    needsCoreConfig name >>= \genesisConfig ->
    needsAuxxMode name >>= \Dict ->
    let nm = makeNetworkMagic (configProtocolMagic genesisConfig) in
    return CommandProc
    { cpName = name
    , cpArgumentPrepare = identity
    , cpArgumentConsumer = do pure ()
    , cpExec = \() -> do
        let epochSlots = configEpochSlots genesisConfig
        sks <- getSecretKeysPlain
        printAction "Available addresses:"
        for_ (zip [0 :: Int ..] sks) $ \(i, sk) -> do
            let pk = encToPublic sk
            addr <- makePubKeyAddressAuxx nm epochSlots pk
            addrHD <- deriveHDAddressAuxx nm epochSlots sk
            printAction $
                sformat ("    #"%int%":   addr:      "%build%"\n"%
                         "          pk:        "%fullPublicKeyF%"\n"%
                         "          pk hash:   "%hashHexF%"\n"%
                         "          HD addr:   "%build)
                    i addr pk (addressHash pk) addrHD
        walletMB <- (^. usWallet) <$> (view userSecret >>= readTVarIO)
        whenJust walletMB $ \wallet -> do
            addrHD <- deriveHDAddressAuxx nm epochSlots (_wusRootKey wallet)
            printAction $
                sformat ("    Wallet address:\n"%
                         "          HD addr:   "%build)
                    addrHD
        return ValueUnit
    , cpHelp = ""
    },

    return CommandProc
    { cpName = "help"
    , cpArgumentPrepare = identity
    , cpArgumentConsumer = do pure ()
    , cpExec = \() -> do
        printAction (mkHelpMessage commands)
        return ValueUnit
    , cpHelp = "display this message"
    }]
  where
    needsData :: Maybe a -> Text -> Name -> Either UnavailableCommand a
    needsData mData msg name = maybe
        (Left $ UnavailableCommand name (msg <> " is not available"))
        Right
        mData
    needsAuxxMode = needsData hasAuxxMode "AuxxMode"
    needsDiffusion = needsData mDiffusion "Diffusion layer"
    needsCoreConfig = needsData mCoreConfig "Genesis.Config"
    needsTxpConfig = needsData mTxpConfig "TxpConfiguration"

procConst :: Applicative m => Name -> Value -> CommandProc m
procConst name value =
    CommandProc
    { cpName = name
    , cpArgumentPrepare = identity
    , cpArgumentConsumer = pure ()
    , cpExec = \() -> pure value
    , cpHelp = "constant"
    }

class ToLeft m a b where
    toLeft :: Either a b -> m a

instance (Monad m, ToLeft m a b, ToLeft m b c) => ToLeft m a (Either b c) where
    toLeft = toLeft <=< traverse toLeft

instance MonadAuxxMode m => ToLeft m PublicKey Int where
    toLeft = either return getPublicKeyFromIndex

instance MonadAuxxMode m => ToLeft m StakeholderId PublicKey where
    toLeft = return . either identity addressHash

getPublicKeyFromIndex :: MonadAuxxMode m => Int -> m PublicKey
getPublicKeyFromIndex i = do
    sks <- getSecretKeysPlain
    let sk = sks !! i
        pk = encToPublic sk
    evaluateNF pk
